V.6 for C&M

Michael Ford

Wolfram Research, Inc.

Initilizations:

Dots[]:=
Manipulate[Module[{ph (* A Placeholder *)},Dynamic[Graphics[{EdgeForm[Thickness[0.001]],{Dynamic[If[N[Sqrt[Min[Table[(((x-ph[[1]]))^2)+(((c+b*x+a*(x^2)-ph[[2]]))^2)/.(#[[i]]),{i,Length[#]}]&[Cases[NSolve[{2(a^2)(x^3)+3b*a*(x^2)+((b^2)+2c*a-2a*ph[[2]]+1)x+(c*b-b*ph[[2]]-ph[[1]])==0},{x}],{Rule[_,_Real]}]]]]]≤0.2,{Red,Disk[ph,0.2]},{Green,Disk[ph,0.2]}]]}/.{ph->#}&/@dots,Dynamic[First[Plot[a*(x^2)+b*x+c,{x,-5,5}]]],If[And[Evaluate[Sequence@@((#≤.2)&/@(N[Sqrt[Min[#]]]&/@(Table[(((x-#[[1]]))^2)+(((c+b*x+a*(x^2)-#[[2]]))^2)/.(#[[i]]),{i,3,Length[#]}]&/@({#[[1]],#[[2]],Cases[NSolve[{2(a^2)(x^3)+3b*a*(x^2)+((b^2)+2c*a-2a*#[[2]]+1)x+(c*b-b*#[[2]]-#[[1]])==0},{x}],{Rule[_,_Real]}]}&/@dots))))]],Style[Text["Congrats!",{0,0}],{Blue,Bold,Large}],{}]},PlotRange->{{-5,5},{-5,5}},ImageSize->{400,400}]]],"  y = a 
(x^2)+ b x + c  ",{{a,1},-3,3},{{b,0},-4,4},{{c,0},-5,5},{{button,a," "}, Button["New Dots",(a0=Random[Real,{-1.5,1.5}];b0=Random[Real,{-2,2}];c0=Random[Real,{-2,2}];range=Clip[x/.NSolve[{If[a0>0,5,-5]==a0*(x^2)+b0*x+c0},{x}],{-5,5}];dots=Table[{#,a0*((#)^2)+b0*#+c0}&[Random[Real,range]]+{0,Random[Real,{-0.15,0.15}]},{Length[dots]}];)]&},ControllerLinking->Automatic,AutorunSequencing->Automatic,Initialization:>(Clear[x];a0=.5;b0=-1.5;c0=2;range=Clip[x/.NSolve[{If[a0>0,5,-5]==a0*(x^2)+b0*x+c0},{x}],{-5,5}];dots={j,k,l,m};j={0.027303532220618543`,1.9594174431049334`};k={3.234340947932494`,2.3789692618376908`};l={3.5157030241981415`,2.906529340880767`};m={1.3730701637342917`,0.88305559166722`};)];
XDots[]:=Module[{a0,x01,x02,x1,x2,j,k,l,m,x,ph (* A Placeholder *)},a0=Random[Real,{-1.5,1.5}];x01=Random[Real,{-5,5}];x02=Random[Real,{-5,5}];x1=-1;x2=1;Module[{range,dots={j,k,l,m}},range=Clip[x/.NSolve[{If[a0>0,5,-5]==a0(x-x01)(x-x02)},{x}],{-5,5}];dots=Table[{#,a0(#-x01)(#-x02)}&[Random[Real,range]],{Length[dots]}];While[False==And[Evaluate[Sequence@@Flatten[Table[-5≤#[[i]]≤5,{i,2}]&/@dots]]],dots=Table[{#,a0(#-x01)(#-x02)}&[Random[Real,range]],{Length[dots]}]];Manipulate[Deploy[Dynamic[Graphics[{EdgeForm[Thickness[0.001]],{Dynamic[If[N[Sqrt[Min[Table[(((x-ph[[1]]))^2)+(((a(x-x1)(x-x2)-ph[[2]]))^2)/.(#[[i]]),{i,Length[#]}]&[Cases[NSolve[{-ph[[1]]+2 (a^2)*(x^3)-3 (a^2)*(x^2) (x1+x2)+a(x1+x2) (ph[[2]]-a*x1*x2)+x (1-2 a*ph[[2]]+(a^2)((x1^2)+4 x1*x2+(x2^2)))==0},{x}],{Rule[_,_Real]}]]]]]≤0.2,Red,Green]],Disk[ph,0.2]}/.{ph->#}&/@dots,Dynamic[First[Plot[a(x-x1)(x-x2),{x,-5,5}]]],Locator[Dynamic[{x1,0},(x1=Clip[#[[1]],{-5,5}])&]],Locator[Dynamic[{x2,0},(x2=Clip[#[[1]],{-5,5}])&]],Dynamic[If[And[Evaluate[Sequence@@((#≤.2)&/@(N[Sqrt[Min[#]]]&/@(Table[(((x-#[[1]]))^2)+(((a(x-x1)(x-x2)-#[[2]]))^2)/.(#[[i]]),{i,3,Length[#]}]&/@({#[[1]],#[[2]],Cases[NSolve[{-#[[1]]+2 (a^2)*(x^3)-3 (a^2)*(x^2) (x1+x2)+a(x1+x2) (#[[2]]-a*x1*x2)+x (1-2 a*#[[2]]+(a^2)((x1^2)+4 x1*x2+(x2^2)))==0},{x}],{Rule[_,_Real]}]}&/@dots))))]],Style[Text["Congrats!",{0,1}],{Blue,Bold,Large}],{}]]},Axes->True,PlotRange->{{-5,5},{-5,5}},ImageSize->{400,400}]]],{{a,1},-1.5,1.5},{{button,a," "}, Button["New Dots",(a0=Random[Real,{-1.5,1.5}];x01=Random[Real,{-5,5}];x02=Random[Real,{-5,5}];range=Clip[x/.NSolve[{If[a0>0,5,-5]==a0(x-x01)(x-x02)},{x}],{-5,5}];dots=Table[{#,a0(#-x01)(#-x02)}&[Random[Real,range]],{Length[dots]}];While[False==And[Evaluate[Sequence@@Flatten[Table[-5≤#[[i]]≤5,{i,2}]&/@dots]]],dots=Table[{#,a0(#-x01)(#-x02)}&[Random[Real,range]],{Length[dots]}]];)]&}]]];

MTransform[]:=Manipulate[Column[{" "," ",Grid[{{Labeled[Slider[Dynamic[a],{-2,2,0.01},ImageSize->Small],Row[{"a = ",Dynamic[a]}],Top],Labeled[Slider[Dynamic[b],{-2,2,0.01},ImageSize->Small],Row[{"b = ",Dynamic[b]}],Top]},{Labeled[Slider[Dynamic[c],{-2,2,0.01},ImageSize->Small],Row[{"c = ",Dynamic[c]}],Top],Labeled[Slider[Dynamic[d],{-2,2,0.01},ImageSize->Small],Row[{"d = ",Dynamic[d]}],Top]}},Spacings -> {2,2}]," "," ",Deploy[Row[{Framed[Dynamic[Graphics[{AbsoluteThickness[2],(*Blue,*) Dynamic[Circle[]],AbsolutePointSize[8],EdgeForm[{Black,Thickness[0.005]}],Table[{Hue[θ/(2π)],Disk[{Cos[θ],Sin[θ]},0.05]},{θ,0,2π,π/6}]},PlotRange->{{-1.1,1.1},{-1.1,1.1}},Axes->True,ImageSize->250]]]," ",Framed[Dynamic[Graphics[{AbsoluteThickness[2], (*Blue,*) Dynamic[GeometricTransformation[Circle[{0,0},1, {0, 2π}],{{a,b},{c,d}}]],AbsolutePointSize[8],EdgeForm[{Black,Thickness[0.005]}],Table[{Hue[θ/(2π)],Disk[{{a,b},{c,d}}.{Cos[θ],Sin[θ]},0.1]},{θ,0,2π,π/6}]},PlotRange->{{-3.1,3.1},{-3.1,3.1}},Axes->True,ImageSize->250]]]}]]},Center],{{a,1},-2,2,ControlType->None},{{b,1},-2,2,ControlType->None},{{c,0},-2,2,ControlType->None},{{d,1},-2,2,ControlType->None},AutorunSequencing->{1,2,3,4,{5,10}}];

Logistic[]:=Module[{pt={0,1},y},Manipulate[SliderPane[Dynamic[pt,(pt[[1]]=0;If[#[[2]]>0,pt[[2]]=#[[2]]])&],Graphics[{Dynamic[First[Plot[Evaluate[y[t]/.NDSolve[{y'[t]==a*y[t](1-((y[t])/b)),y[0]==pt[[2]]},y[t],{t,0,x}]],{t,0,x}]]],Dashed,Red,Dynamic[Line[{{0,b},{x,b}}]],Dynamic[Text["b = "<>ToString[b],{x,b},{1,1}]]},PlotRange->{{0,x},{0,3}},Axes->True,AspectRatio->1]],Text[Framed["y'[t]=a*y[t](1-
((y[t])/b))"]],{{a,.3},0.01,1},{{b,2},0.01,3},{x,10,100}]];

PvP[]:=Module[{prey,pred,prey0={0,20},pred0={0,35},y},Manipulate[Deploy[Row[{Pane[Graphics[{Dynamic[First[Plot[Evaluate[{prey[t],pred[t]}/.NDSolve[{prey'[t]==prey[t] (a-b*pred[t]),pred'[t]==pred[t] (-c+d*prey[t]),prey[0]==prey0,pred[0]==pred0},{prey[t],pred[t]},{t,0,x}]],{t,0,x}]]],Dashed,Red,Dynamic[Line[{{0,a/b},{x,a/b}}]],Dynamic[Text["a/b = "<>ToString[a/b],{x,a/b},{1,1}]],Green,Dynamic[Line[{{0,c/d},{x,c/d}}]],Dynamic[Text["c/d = "<>ToString[c/d],{x,c/d},{1,1}]],Blue,Locator[Dynamic[prey0,(prey0[[1]]=0;If[#[[2]]>0,prey0[[2]]=#[[2]]])&]],Dynamic[Text["prey0",prey0,{-2,0},Background->White]],Purple,Locator[Dynamic[pred0,(pred0[[1]]=0;If[#[[2]]>0,pred0[[2]]=#[[2]]])&]],Dynamic[Text["pred0",pred0,{-2,0},Background->White]]},PlotRange->{{0,x},{0,100}},Axes->True,AspectRatio->1]],Pane[Dynamic[ParametricPlot[Evaluate[{prey[t],pred[t]}/.NDSolve[{prey'[t]==prey[t] (a-b*pred[t]),pred'[t]==pred[t] (-c+d*prey[t]),prey[0]==prey0[[2]],pred[0]==pred0[[2]]},{prey[t],pred[t]},{t,0,0.5}]],{t,0,0.5},ImageSize->{300,300}]]]}]],Text[Framed[ColumnForm[{"prey'[t]=prey[t](a-b*pred[t])","pred'[t]=pred[t](-c+d*prey[t])"}]]],{{a,40},10,90},{{b,1},0.01,3},{{c,50},10,90},{{d,2},0.01,3},{{x,0.5},0.25,3}]];

PlinkoBifurcate[prob_,num_]:=With[{left=Count[Table[Random[],{num}],a_/;a<prob]},{left,num-left}];

PlinkoUpdateDisks[prob_,disklist_]:=Module[{list},list=PlinkoBifurcate[prob,#]&/@disklist;(#[[1]]+#[[2]])&/@Join[{{list[[1,1]],0}},Partition[Drop[Rest[Flatten[list]],-1],2],{{0,Last[Last[list]]}}]];

Plinko[]:=Module[{disklist={0},num=1,ht=3,bincnts=Table[0,{4}],maxval=0,totbincnt=0,maxbincnt=0,histoht=2,mid=5,rad=0.4,prob=0.5,dispNums=False},Framed[ColumnForm[{" ",Row[{"Probability to the Left: ",InputField[Dynamic[prob,(prob=#;bincnts=Table[0,{ht+1}])&,Number,FieldSize->6]]}],Row[{"Height: ",InputField[Dynamic[ht,(ht=#;bincnts=Table[0,{#+1}];mid=#+2;histoht=2#/3;)&,Number,FieldSize->6]]}],Row[{Button["Run",disklist={num};maxval=Max[disklist];While[Plus@@disklist=!=0,Pause[0.3];disklist=PlinkoUpdateDisks[prob,disklist];maxval=Max[disklist];If[Length[disklist]==Length[bincnts],bincnts+=disklist;totbincnt=Plus@@bincnts;maxbincnt=100. Max[bincnts];disklist={0};];],Method->"Queued"]," ",Button["Clear Bins",bincnts=Table[0,{ht+1}];],"   Show Percents: ",Checkbox[Dynamic[dispNums]]}],Row[{"Number of Disks to Drop: ",SetterBar[Dynamic[num],{1,2,3,4,5,8,10,50,100,1000},Appearance->"Row"]}],Row[{" ",Deploy[Dynamic[Graphics[{Dynamic[totbincnt=Plus@@bincnts];Dynamic[maxbincnt=100. Max[bincnts]];
Dynamic[maxval=Max[disklist]];Text[StyleForm["Prob(→)="<>ToString[prob], FontSize->12], {0.5,ht/2}, {-1,0}]
,PointSize[Min[0.1/ht,0.015]],
		Red,		Dynamic[Rectangle[{#[[1]], -histoht}, {#[[1]]+2, -histoht+0.9 #[[2]] histoht/Max[bincnts, 1]}]&/@ Transpose[{Range[0,2ht+1,2],bincnts}]],
		Black,
		Table[Line[{{i,0},{i,-histoht}}], {i,0,2mid-2,2}],
		Line[{{0,-histoht},{2mid-2,-histoht}}],
		Blue,Table[Point[{i,j}],{j,ht-1,0,-1}, {i,mid-(ht-j),mid+(ht-j-2),2}],Black,Dynamic[Table[If[disklist[[i+1]]=!=0,{Opacity[.75(((disklist[[i+1]])/maxval)-1)+1],Disk[{ht+2-Length[disklist]+2i,rad+ht-Length[disklist]},rad]},{}],{i,0,Length[disklist]-1}]],Dynamic[If[dispNums,{Dynamic[Table[Text[ToString[N[100((bincnts[[i+1]])/(Max[totbincnt,1]))]]<>"%",{1+2i, -histoht+0.9bincnts[[i+1]] histoht/Max[bincnts, 1]},{0,-1}],{i,0,ht}]],Dynamic[Table[Text[ToString[(((100ht!)/(i!(ht-i)!))*((prob^((ht-i))))*((1-prob)^i))]<>"%",{1+2i,-histoht},{0,1}],{i,0,ht}]]},{}]]},PlotRange->{{-1,2ht+3},{-histoht-.075ht,ht}},Background->White,ImageSize->{500, 334}]]]," "}]},Center]]];

Taylor[]:=Manipulate[pt={#,func/.{x->#}}&[autorunvar];If[view=="Graphs",SliderPane[Dynamic[pt,(pt={First[#],func/.{x->First[#]}};autorunvar=First[pt])&],
Dynamic[Graphics[
{First[Plot[func,{x,-2π,2π}]],First[Plot[Evaluate[Normal[Series[func,{x,First[pt],IntegerPart[ApproxOrder]}]]],{x,-2π,2π}]]/.{Hue[__]->Hue[0,.6,.6]}},ImageSize->Large,PlotRange->{{-2π,2π},{-3,3}},Axes->True, AspectRatio -> Automatic]]],Deploy[Dynamic[Graphics[{First[Plot[Evaluate[Abs[func-Normal[Series[func,{x,First[pt],IntegerPart[ApproxOrder]}]]]],{x,-2π,2π}]],Circle[{autorunvar,0},.15],Red,Dynamic[Line[{{First[pt],-1},{First[pt],1}}]]},ImageSize->Large,PlotRange->{{-2π,2π},{-3,3}},Axes->True, AspectRatio -> Automatic]]]],{{pt,{0,0}},(*Manipulator[Dynamic[pt,(pt=#;autorunvar=First[pt])&]]&,*)ControlType->None},{{func,Sin[x],"Function of X: "},ControlType->InputField},{{ApproxOrder,1,"Approximation Order:"},0,11,1},{{view,"Graphs","View: "},{"Graphs","Difference"}},{{autorunvar,0},-2π,2π,ControlType->None},AutorunSequencing->{4,3},ControllerLinking->True];

Options[FunctionZoom] = {Range->{{-1,1},{-1,1}}, Point->{0,0}, Zoom->1};

FunctionZoom[function_,var_,opts0___Rule]:= DynamicModule[{zoom,zoom2,range,gpos,grab,FuncOfX=function,pt,x=var, LEP, REP, BEP, UEP, L, R, B, U,opts},opts=ReplacePart[{opts0},Flatten[{Position[{opts0},Rule[Zoom,_]],2}]->Evaluate[Clip[{opts0}[[Sequence@@Flatten[{Position[{opts0},Rule[Zoom,_]],2}]]],{-6.5,45}]]];
{range, pt, zoom} = {Range, Point, Zoom} /. opts/.Options[FunctionZoom];
LEP=range[[1,1]];REP=range[[1,2]];BEP=range[[2,1]];UEP=range[[2,2]];
L=(LEP/(2^zoom));R=(REP/(2^zoom));B=(BEP/(2^zoom));U=(UEP/(2^zoom));

Deploy[Panel[Column[{Grid[{{Column[{Pane[" "],Pane[" "],Grid[{{Button["Zoom Out",zoom=Clip[zoom-.5,{-6.5,45}];zoom2=2^zoom;L=-((range[[1,2]]-range[[1,1]])/(2*zoom2));R=((range[[1,2]]-range[[1,1]])/(2*zoom2));B=-((range[[2,2]]-range[[2,1]])/(2*zoom2));U=((range[[2,2]]-range[[2,1]])/(2*zoom2))],Button["Zoom In",zoom=Clip[zoom+.5,{-6.5,45}];zoom2=2^zoom;L=-((range[[1,2]]-range[[1,1]])/(2*zoom2));R=((range[[1,2]]-range[[1,1]])/(2*zoom2));B=-((range[[2,2]]-range[[2,1]])/(2*zoom2));U=((range[[2,2]]-range[[2,1]])/(2*zoom2))],Button["Reset All",{range, pt, zoom} = {Range, Point, Zoom} /. opts/.Options[FunctionZoom];zoom2=2^zoom;L=-((range[[1,2]]-range[[1,1]])/(2*zoom2));R=((range[[1,2]]-range[[1,1]])/(2*zoom2));B=-((range[[2,2]]-range[[2,1]])/(2*zoom2));U=((range[[2,2]]-range[[2,1]])/(2*zoom2));]}}],Pane[" "]}]}}],Grid[{{Pane[" "],Panel[Pane[EventHandler[Dynamic[Graphics[{Dynamic[First[Plot[FuncOfX,Evaluate[Join[{var},range[[1]]]], PlotStyle -> Blue]]],Red,PointSize[0.02],Dynamic[Point[{pt[[1]],Clip[pt[[2]],{range[[2,1]],range[[2,2]]}]}]],Black,{EdgeForm[{Thickness[0.0025],Opacity[0.6]}],Opacity[0.05],Translate[Polygon[{{Dynamic[L],Dynamic[U]},{Dynamic[L],Dynamic[B]},{Dynamic[R],Dynamic[B]},{Dynamic[R],Dynamic[U]}}],Dynamic[pt]]}},PlotRange->{{Dynamic[range[[1,1]]],Dynamic[range[[1,2]]]},{Dynamic[range[[2,1]]],Dynamic[range[[2,2]]]}},Axes->True, AspectRatio -> Automatic,Background->White,ImagePadding->{{5,5},{5,5}}]],{"MouseDown":>If[MousePosition["Graphics"]=!=None,grab=MousePosition["Graphics"];gpos=If[(L+pt[[1]]≤MousePosition["Graphics"][[1]]≤R+pt[[1]]&&B+pt[[2]]≤MousePosition["Graphics"][[2]]≤U+pt[[2]])||(pt[[1]]-((REP-LEP)/25)≤MousePosition["Graphics"][[1]]≤((REP-LEP)/25)+pt[[1]]&&Clip[pt[[2]],{range[[2,1]],range[[2,2]]}]-((UEP-BEP)/25)≤MousePosition["Graphics"][[2]]≤Clip[pt[[2]],{range[[2,1]],range[[2,2]]}]+((UEP-BEP)/25)),"locator","graphics"]],"MouseDragged":>If[grab=!=None,Switch[gpos,"locator",(pt[[1]]+=Part[(MousePosition["Graphics"]//.{None->grab})-grab,1];pt[[2]]=(FuncOfX//.{x->pt[[1]]});grab=MousePosition["Graphics"]),"graphics",(range-=(MousePosition["Graphics"]//.{None->grab})-grab;pt[[1]]=Clip[pt[[1]],{range[[1,1]],range[[1,2]]}])]]}]],{Background->White}],Pane[""],Panel[Pane[Graphics[{Dynamic[First[Plot[FuncOfX,Evaluate[{var,L+pt[[1]],R+pt[[1]]}]]]],{Opacity[0.05],EdgeForm[{Thickness[0.0025],Opacity[0.6]}],Dynamic[Translate[Polygon[{{Dynamic[L],Dynamic[U]},{Dynamic[L],Dynamic[B]},{Dynamic[R],Dynamic[B]},{Dynamic[R],Dynamic[U]}}],Dynamic[pt]]]},Red,Point[Dynamic[pt]]},PlotRange->{{Dynamic[L+pt[[1]]],Dynamic[R+pt[[1]]]},{Dynamic[B+pt[[2]]],Dynamic[U+pt[[2]]]}},Axes->False,PlotLabel->Framed[HoldForm[Dynamic[ScientificForm[N[pt],6]]" ± "Dynamic[ScientificForm[N[{((R-L)/2),((U-B)/2)}],6]]],Background->White] ,ImagePadding->{{3,3},{3,30}},AspectRatio -> Automatic,Background->White]],{Background->White}],Pane[" "]}}],Pane[" "]},Center]]] ];

Algebra

"Quadratic Dots"

Dots[]

X-Axis version of Dots

XDots[]

Matrix Transform

MTransform[]

Diff Eq's

Logistic

Logistic[]

Pred vs. Prey

PvP[]

Really Cool Stuff

Plinko

Plinko[]

Taylor

Clear[x];

Taylor[]

Zoom

FunctionZoom[Sin[x]+Cos[x],x,Range->{{-2π,2π},{-3,3}},Point->{0,1},Zoom->0]

FunctionZoom[Tan[x],x,Range->{{-2π,2π},{-4,4}},Point->{0,0},Zoom->0]

Useful Tricks

Module[{PS=0,U=0,P=0},Row[{Grid[{{"Point Setter",Slider[Dynamic[PS]]},{"Updater",Slider[Dynamic[U,(U=#;P=PS)&]]},{"Point",Slider[Dynamic[P]]}}],Graphics[{Line[{{0,0},{1,0}}],Line[{{0,0.1},{1,0.1}}],Line[{{0,0.2},{1,0.2}}],PointSize[0.05],Blue,Point[{Dynamic[PS],0.2}],Red,Point[{Dynamic[U],0.1}],Green,Point[{Dynamic[P],0}]},ImageSize->{400,100}],Column[{Dynamic[PS],Dynamic[U],Dynamic[P]}]}]]

NotebookOpen["C:\\Program Files\Wolfram Research\Mathematica\NB files\Intern\Finished\Demos\Dynamic Workaround.nb"];